#
package FileTable;
#
# An implementation of record tables that works with an SQL backend
# (mSQL 2).
#
use strict;

# Standard packages
use Fcntl;
use DBI;
use FileHandle;
use English;
use Carp;

# Nonstandard packages
use Validate;
use FileTable::Record;

# Declare variables
use vars qw($DEBUG $database $databaseserver $dbhandle $dbopencount);

$DEBUG = 0; # Controls some random output to stderr

$database = "counter";
$databaseserver = "";

# Variables.
$dbhandle = undef;
$dbopencount = 0;

# Check database liveness. Adapted from Apache::DBI
sub ping {
    my($dbh) = @_;
    my $ret = 0;
    eval {
	local $SIG{__DIE__}  = sub { return (0); };
	local $SIG{__WARN__} = sub { return (0); };
	local $SIG{PIPE} = sub { return (0); }; # hta add
	# adapt the select statement to your database:
	$ret = $dbh->do('select 1');
    };
    return ($@) ? 0 : $ret;
}

sub dbconnect {
    # Connect to the database, if it is not connected or if it is lost
    if ($dbhandle) {
	# not good enough...
	#my $rc = $dbhandle->ping();
	my $rc = ping($dbhandle);
	if ($rc) {
	    return 0; # OK - do nothing
	}
    }
    $DEBUG && warn "Opening database in process $$\n";
    my $dbstring = "DBI:mysql:database=$database";
    if ($databaseserver) {
	$dbstring .= ";host=$databaseserver";
    }
    $dbhandle = DBI->connect($dbstring, "counter", "password")
	    || die "Unable to open counter DB - $!\n";
    return 1;
}

# internal sub to return the dbhandle of a filehandle for use in
# a MySQL operation
# it used to be stored as a field in the FileTable record, but that turned
# out to be suboptimal for maintaining its state...
sub dbhandle {
    my $self = shift;
    dbconnect();
    return $dbhandle;
}


sub open {
    my $filename = shift;
    my $flags = shift; # O_CREAT and O_RDWR flags
    $flags = 0 if !defined($flags);
    my $self = {};
    my $filearray = {};
    my $cleanarray = {};
    #my CONFIG; # Wish I could have local filehandles....
    my $sth;
    my $status;
    my @names;
    my @types;

    $flags = 0 if !defined($flags);
    bless $self;

    open(CONFIG, "$filename.conf")
	|| die "Unable to open $filename.conf - $!\n";
    # Keep track of the config - don't know what to do with it yet....
    my $cur;
    while (<CONFIG>) {
	chop;
	next if (/^#/ || /^\s*$/);
	if (/^(\S+):\s*/) {
	    $$self{"*$1"} = $'; # '
	    $cur = "*$1";
	} elsif (/^\s+(\S)/) {
	    $$self{$cur} .= "\n";
	    $$self{$cur} .= "$1$'";
	}
    }
    if ($$self{"*validate"}) {
	my $expr;

	# 980921: this is wrong....die "$@ in validate\n" if $@;
        # For some reason Perl goes wild over next sentence if not
        # written as two strings....
        $expr = "$$self{'*validate'}" . "->new()";
	# Running without validator is OK for read, but NOT for write
	if ($flags & O_RDWR) {
	    eval "use $$self{\"*validate\"}";
	    die "Validator compile failed: $@" if $@;
	}
	if (! eval("defined($expr)")) {
	    $$self{"*VALID"} = "not present";
	    if ($flags & O_RDWR) {
		die "Cannot open $filename for write without using $$self{'*validate'}\n";
	    }
	} else {
	    $$self{"*VALID"} = eval $expr;
	}
    }
    # Pull in the class, if necessary
    if ($$self{"*class"}) {
	eval "require $$self{\"*class\"}";
	die "Class compile failed: $@" if $@;
    }
    $$self{_MODE} = $flags;
    #dbconnect();

    (my $table = $filename) =~ s/.*\///; # name only, no dir
    $$self{_TABLE} = $table;
	gettableinfo($self);

    if ($$self{"*clean"} && $$self{"*clean"} =~ /yes/) {
        # Ought to check that f_clean is present as fieldname
	if (($flags & O_RDWR) &&!$$self{"*validate"}) {
	    die "Cannot have a Clean file without a validator";
	}
	$$self{"*CLEAN"} = 1;
    }
    $self->{"*NAME"} = $filename;
# garg - this is ugly - ought to use mSQL SEQUENCE!
# HTA 2005-02-16: At last it is gone!
#    if ($self->{"*keystyle"} && $self->{"*keystyle"} eq "number") {
#	my $lastfile = "$self->{'*NAME'}.last";
#	if (-f $lastfile) {
#	    open(LAST, $lastfile);
#	    $self->{"*LASTNUM"} = <LAST> + 0;
#	} else {
#	    open(LAST, ">$lastfile");
#	    print LAST "0";
#	    $self->{"*LASTNUM"} = 0;
#	}
#	close LAST;
#    }
     ++ $dbopencount;
     return $self;
}

sub gettableinfo {
    my $self = shift;
    my $sth;
    my $status;
    my $dbhandle = $self->dbhandle();
    my $table = $$self{_TABLE};

    # Retrieve the field names for the table,
    # see that the required ones are present, and make a note of which
    # fields to store.
    $sth = $dbhandle->prepare("LISTFIELDS $table");
    $sth->{PrintError} = 0; # Don't go onscreen if it fails
    $status = $sth->execute;
    if (!$status) {
	if ($sth->errstr =~ /Unknown table/ | $sth->errstr =~ /doesn't exist/) { # '
	    if ($$self{_MODE} & O_CREAT || 1) {
		$DEBUG && warn "Create statement: $$self{'*sqlcreate'}\n";
		$dbhandle->do($$self{'*sqlcreate'})
		    || die "Create failed";
		$sth = $dbhandle->prepare("LISTFIELDS $table");
		$sth->execute || die "Listfields $table failed after create";
	    } else {
		die "DB table does not exist";
	    }
	} else {
	    die "listfields $table failed - ", $sth->errstr;
	}
    }
	
    my $numFields = $sth->{'NUM_OF_FIELDS'};
    my @names = @{$sth->{NAME}};
    my @types;
    # FIXME: Change FileTable::Record::fieldlist to use _DBINFO structure,
    # so that we can remove _DBFIELDS and _DBFIELDTYPES.
    $$self{_DBFIELDS} = \@names;
    # HTA 2004-09-16: Nobody seems to use this field...
    #my $name;
    #for $name (@names) {
    #   $$self{_DBHASFIELD}{$name} = 1;
    #}
    if ($sth->{TYPE}) {
	@types = @{$sth->{TYPE}};
    } else {
	warn "No type info\n";
    }
    $$self{_DBFIELDTYPES} = \@types;
    $$self{_DBINFO} = parsedbinfo($sth);
    #warn "f_key length: ", $self->{_DBINFO}->{f_key}->{length}, "\n";
    #warn "f_key type  : ", $self->{_DBINFO}->{f_key}->{type}, "\n";
}

# Parse the info returned from LISTINFO into something sensible & usable
sub parsedbinfo {
    my $sth = shift;

    my @names = @{$sth->{NAME}};
    my @types = @{$sth->{TYPE}};
    my @lengths = @{$sth->{mysql_length}};
#    warn "Names: ", join(" ", @names);
#    warn "Types: ", join(" ", @types);
    my $info = {};

    for my $ix (0..@names-1) {
	my $name = $names[$ix];
	my $type = $types[$ix];
	my $length = $lengths[$ix];
	$$info{$name} = {"type" => $type, "length" => $length};
	# warn "$name: type $type length $length\n";
    }
    return $info;
}

# Lock and unlock routines for DB writing.
sub lock {
    my $self = shift;
    warn "Not locking anything\n";
}

sub unlock {
    my $self = shift;
    warn "Not unlocking anything\n";
}

sub close {
    my $self = shift;
    my $file = $self->{"*NAME"};

    if (!$file) {
	warn "close called on nameless (closed?) file\n";
	return;
    }
    undef %$self;
    -- $dbopencount;
    if ($dbopencount <= 0) {
	if (!defined($dbhandle) || $dbopencount < 0) {
	    $DEBUG && warn "$file: More closes than opens????\n";
	} else {
	    $dbhandle->disconnect();
	    undef $dbhandle;
	}
    }
}

sub DESTROY {
    my $self = shift;
    warn "DESTROY called on nondef object\n" if !$self;
    # In Perl 5.6, it gives me warnings about closing too many times.
    # Perl 5.0006 couldn't be bothered.
    # Close does not destroy object, merely empties it. So this works.
    $self -> close if $self->{'*NAME'};
}

# Get the list of "user-modifiable" fields for this file
sub fields {
    my $self = shift;
    my $fields = $self->{"*fields"};
    return split(" ", $fields);
}

sub internalfields {
    my $self = shift;
    my $fields = $self->{"*internalfields"};
    return split(" ", $fields);
}    

#
# Get the keys of the file
# NOTE: For big files, each() returns in considerably fewer minutes
#
sub keys {
    my $self = shift;
    my $table = $self->{_TABLE};
    my @res;
    my @restab;

    my $sth = $self->dbhandle()->prepare("SELECT f_key FROM $table");
    $sth->execute || die "keys select failed";
    while (1) {
	@res = $sth->fetchrow_array();
	last if $#res == -1;
	die "Wrong number of elms: $#res" if $#res != 0;
        push(@restab, $res[0]);
    }
    @restab;
}

sub each {
    my $self = shift;
    my $key;
    my $val;
    my $table = $self->{_TABLE};

    if (!$self->{_EACH}) {
	my $dbh = $self->dbhandle();
	my $sth = $dbh->prepare("SELECT f_key FROM $table");
	$sth->execute || die "keys select failed";
	$self->{_EACH} = $sth;
    }
    my $sth = $self->{_EACH};
    my @res = $sth->fetchrow_array();
    last if $#res == -1;
    die "Wrong number of elms: $#res" if $#res != 0;
    $key = $res[0];
    return $key;
}

sub new {
# Call as file->new()
# Return a new record object without a key.

    my $self = shift;
    my $object;

    if ($self->{"*class"}) {
	$object = FileTable::Record::new($self->{"*class"});
    } else {
	$object = FileTable::Record::new('FileTable::Record');
    }
    $object->{"*FILE"} = $self;
    return $object;
}

sub get {
# Call as file->get(key)
# Return a new object if O_CREAT is given in flags; if not,
# return "undef".

    my $self = shift;
    my $key = shift;
    my $flags = shift;
    my $object;
    my($textform, $line);
    my $dbh = $self->dbhandle();
    my $table = $self->{_TABLE};

    my $sth = $dbh->prepare("SELECT f_key, f_raw FROM $table WHERE f_key = ?");
    my $dbkey;
    # Truncate key if necessary
    if ($self->{_DBINFO}->{f_key}->{type} eq DBI::SQL_VARCHAR
	&& $self->{_DBINFO}->{f_key}->{length} < length($key)) {
	# FIXME: length() is Unicode chars. dunno what DBINFO length is.
        # DEBUG: something's wrong when running as mod_perl on gimel
	#warn "type is " . $self->{_DBINFO}->{f_key}->{type} . "\n";
	#warn "length is " . $self->{_DBINFO}->{f_key}->{length} . "\n";
	#warn "DBI::SQL_VARCHAR is " . DBI::SQL_VARCHAR . "\n";
	my $len = $self->{_DBINFO}->{f_key}->{length};
	if ($len == 0) {
	    warn "Bug in _DBINFO suspected - ignoring check\n";
	    $dbkey = $key;
	} else {
	    warn "truncating $table f_key to $len: $key\n";
	}
	$dbkey = substr($key, 0, $len);
    } else {
	$dbkey = $key;
    }
    my $count = $sth->execute($dbkey) || die "Select failed";
    $flags = 0 if !defined($flags);
    if ($count == 0) {
	if (($flags & O_CREAT) == 0) {
	    return undef;
	} elsif (($self->{_MODE} & O_RDWR) == 0) {
	    die "Attempt to create entry in read-only file";
	} else {
	    $sth = $dbh->prepare("INSERT INTO $table (f_key) VALUES(?)");
	    $sth->execute($key)
		|| croak "Insert failed";
	    $object = $self->makeobject($key, "");
	    $object->stored("placeholder"); # Special signal: In DB, but not created
	}
    } else {
	my @res = $sth->fetchrow_array();
	$key = $res[0]; # Normalize - use key from file, not from argument
	$textform = $res[1];
	$object = $self->makeobject($key, $textform);
    }
    $object;
}

sub getclean {
# Call as file->getclean(key)
# NOTE: You NEVER store back clean records - so the "FILE" is sabotaged;
# this should give a runtime error in the store, but loses the DB ref.
    my $self = shift;
    my $key = shift;
    my $object = FileTable::Record->new;
    my ($textform, $line);

    if (!$self->{"*CLEAN"}) {
	return $self->get($key);
    }
    my $dbh =  $self->dbhandle();
    my $table = $self->{_TABLE};
    my $sth =  $dbh->prepare("SELECT f_clean FROM $table WHERE f_key = ?");
    my $count = $sth->execute($key) || die "Select failed";
    if ($count == 0) {
        return undef;
    }
    my @res = $sth->fetchrow_array();
    $textform = $res[0];
    if (!defined($textform) || length($textform) == 0) {
	return undef;
    }
    $object = $self->makeobject($key, $textform);
    delete $object->{"*FILE"}; # Make sure rewrite doesn't work;
    $object;
}

sub getbykey {
    my($self, $field, $value) = @_;

    # Note: We can get on any field that is represented as a field
    # in the database. And this routine does not chec, but crashes.
    # Note: With MySQL and TEXT fields, the compare is case-folding.
    #$value =~ tr/A-Z/a-z/;
    my $dbh = $self->dbhandle();
    my $table = $self->{_TABLE};
    my $sth = $dbh->prepare("SELECT f_key, f_raw FROM $table WHERE $table.$field = ?");
    my $count = $sth->execute($value)
	|| die "Getbykey $field $value failed";
    if ($count == 0) {
	return undef;
    } elsif ($count > 1) {
	warn "Note: $field=$value has $count occurences\n";
    }
    my @res = $sth->fetchrow_array();
    return $self->makeobject($res[0], $res[1]);
}

sub select {
# Return a list of objects, based on an SQL query.
# Any query is possible, but what fields to return is fixed.
    my $self = shift;
    my $query = shift;
    my @execargs = @_;

    my $dbh = $self->dbhandle();
    my $table = $self->{_TABLE};
    my $sth = $dbh->prepare("SELECT f_key, f_raw FROM $table WHERE $query");
    my $count = $sth->execute(@execargs)
        || croak "Select $query failed";
    my @reslist;
    if ($count > 0) {
	my $res;
	while ($res = $sth->fetchrow_arrayref()) {
	    push(@reslist, $self->makeobject($$res[0], $$res[1]));
	}
    }
    return @reslist;
}
sub selectclean {
# Return a list of objects, based on an SQL query.
# Any query is possible, but what fields to return is fixed.
    my $self = shift;
    my $query = shift;
    my @execargs = @_;

    my $dbh = $self->dbhandle();
    my $table = $self->{_TABLE};
    my $sth = $dbh->prepare("SELECT f_key, f_clean FROM $table WHERE $query");
    my $count = $sth->execute(@execargs)
        || die "Select $query failed";
    my @reslist;
    if ($count > 0) {
	my $res;
	while ($res = $sth->fetchrow_arrayref()) {
	    push(@reslist, $self->makeobject($$res[0], $$res[1]));
	}
    }
    return @reslist;
}

sub selectany {
# Unbridled select: Get any data at all.
    my $self = shift;
    my $query = shift;
    my @execargs = @_;

    my $dbh = $self->dbhandle();
    my $table = $self->{_TABLE};
    my $sth = $dbh->prepare("SELECT $query")
	|| die "Selectany prepare $query failed";
    my $count = $sth->execute(@execargs)
        || die "Selectany $query failed";
    my @reslist;
    if ($count > 0) {
	my $res;
	while ($res = $sth->fetchrow_hashref()) {
	    push(@reslist, $res);
	}
    }
    return @reslist;
}    

sub dosql {
# Unbridled SQL statement - do anything.
    my $self = shift;
    my $query = shift;
    my @execargs = @_;

    my $dbh = $self->dbhandle();
    my $table = $self->{_TABLE};
    my $sth = $dbh->prepare("$query")
	|| die "dosql prepare $query failed";
    my $count = $sth->execute(@execargs)
        || die "dosql $query failed";
    return ($count, $sth);
}    
    
sub count {
# Count the result of some kind of query
   my $self = shift;
   my $query = shift;
   my @execargs = @_;
   
   my $dbh = $self->dbhandle();
   my $table = $self->{_TABLE};
   my $sth;
   if (!defined($query) || $query eq "") {
       $sth = $dbh->prepare("SELECT count(*) FROM $table");
   } else {
       $sth = $dbh->prepare("SELECT count(*) FROM $table WHERE $query");
   }
   my $count = $sth->execute(@execargs)
        || croak "Select $query failed";
   my $res = $sth->fetchrow_arrayref();
   return $$res[0];
}

sub counts {
# Compute the numbers of occurrences of values in a given field
# NOTE: For reasons of consistency, keys are always in LOWER CASE
   my $self = shift;
   my $field = shift;
   
   my $dbh = $self->dbhandle();
   my $table = $self->{_TABLE};
   my $query = "SELECT $table.$field, count(*) FROM $table GROUP BY $table.$field";
   my $sth = $dbh->prepare($query);
   $sth->execute() || die "Counts $table.$field failed";
   my $res = $sth->fetchall_arrayref();
   my %hash;
   for (my $idx = 0; $idx <= $#$res; $idx++) {
     my $row = $res->[$idx];
     $hash{"\L$$row[0]"} = $$row[1];
   }
   return %hash;
}

sub makeobject {
# Internal routine to build a record from its
# text representation
# NOTE: must be in close sync with "textform" routine
# elsewhere in this file
    my $self = shift;
    my $key = shift;
    my $textform = shift;
    my $line;

    my $object = $self->new();

    $object->{"*KEY"} = $key;
    $object->stored(1); # Make rekey impossible
    return $object if !defined($textform);
    # Perl after 5.008 some time "knows" that the stored data are
    # not Unicode, even when it is. Tell it that it is.
    if ($] > 5.008) {
	require Encode;
	if (!utf8::is_utf8($textform)) {
	    # reason for is_utf8 test: makeobject() also used by
	    # unfreeze routine, which creates from already-utf8 data
	    eval {
		# contrary to doc, default is FB_CROAK, it seems...
		$textform = Encode::decode("utf8", $textform, Encode::FB_CROAK());
	    };
	    if ($@) {
		warn "Malformed UTF-8 - Decoding as ISO 8859-1\n";
		warn $@ if $@ !~ /does not map to Unicode/;
		$textform = Encode::decode("iso-8859-1", $textform);
		# HACK:
		# Some objects have some Unicode characters in them, but some
		# 8859-1 characters. Repair.
		if ($textform =~ /[\x{C2}-\x{DF}][\x{80}-\x{bf}]/) {
		    warn "Some UTF-8(1) characters found\n";
		    while ($textform =~ /([\x{C0}-\x{DF}])([\x{80}-\x{bf}])/) {
			my $toreplace = $1 . $2;
			my $replacement = chr(((ord($1) & 0x1F) << 6) + (ord($2) & 0x3F));
			#warn sprintf("Replacing %x.%x with %x\n", ord($1), ord($2),  ord($replacement));
			$textform =~ s/$toreplace/$replacement/g;
		    }
		} elsif ($textform =~ /[\x{E0}-\x{FF}][\x{80}-\x{bf}]{2}/) {
		    warn "Some UTF-8(2-3) characters found. Skipping\n";
		}
	    }
	}
    }
    for $line (split(/\n/, $textform)) {
        # FIX 980212: fieldnames are charset limited
        # used to be "up to colon", but values can have colons
	if ($line =~ /^([-a-z0-9A-Z_]+):/) {
	    my $val = $'; #'
	    my $field = $1;
	    if ($val =~ /\\/) {
		$val =~ s/\\n/\n/g;
		$val =~ s/\\\\/\\/g;
	    }
	    $object->{$field} = $val;
	} else {
	    warn "Illegal line in object $key: $line\n";
	}
    }
    $object;
}


# Get a new number for this file. 
# This routine is internal - called from newnum() and from
# newkey() in FileTable::Record.
sub _newnumber {
    my $self = shift;
    my $dbh = $self->dbhandle();
    my $table = $self->{_TABLE};
    my $key;
    my $object;

    # Insert an empty object into the table and let auto_increment sort it out
    my $sth = $dbh->prepare("INSERT INTO $table () VALUES()");
    $sth->execute() || croak "Insert failed";
    croak "No insertid returned" if !$sth->{mysql_insertid};
    return $sth->{mysql_insertid};

} 

# Get a record with a new number. Probably deprecated.
# This version depends on f_key being an auto_increment field.
sub newnum {
    my $self = shift;
    my $dbh = $self->dbhandle();
    my $table = $self->{_TABLE};
    my $key;
    my $object;

    $key = $self->_newnumber();
    $object = $self->makeobject($key, "");
    $object->stored("placeholder"); # Special signal: In DB, but not created
    return $object;
}	

1;
